Chapter 11

Code example 11-1
Sub GetTuition()
    Dim varTu
ition As Variant, varAge As Variant
    Dim varAPR As Variant, varPresVal As Variant
    Dim Savings As Variant, Fmt As String
varTuition = 50000
varAge = 18
varAPR = .065
varPresVal = 0
Fmt = "$###,##0.00"

Savings = Pmt(varAPR/12, varAge*12, varPresVal, varTuition)
MsgBox("You must save at least " & Format(Savings, Fmt) _
 & "each month")
End Sub
Code example 11-2
Private Function HandleButtonClick(intBtn As Integer)
' This function is called when a button is clicked.
' The intBtn argument indicates which button was clicked.

    ' Constants for the commands that can be executed.
    Const conCmdGotoSwitchboard = 1
    Const conCmdOpenFormAdd = 2
    Const conCmdOpenFormBrowse = 3
    Const conCmdOpenReport = 4
    Const conCmdCustomizeSwitchboard = 5
    Const conCmdExitApplication = 6
    Const conCmdRunMacro = 7
    Const conCmdRunCode = 8
    Const conCmdOpenPage = 9

    ' An error that is special cased.
    Const conErrDoCmdCancelled = 2501
   
    Dim con As Object
    Dim rs As Object
    Dim stSql As String

On Error GoTo HandleButtonClick_Err

    ' Find the item in the Switchboard Items table
    ' that corresponds to the button that was clicked.
    Set con = Application.CurrentProject.Connection
    Set rs = CreateObject("ADODB.Recordset")
    stSql = "SELECT * FROM [Switchboard Items] "
    stSql = stSql & "WHERE [SwitchboardID]=" & _
        Me![SwitchboardID] & " AND [ItemNumber]=" & intBtn
    rs.Open stSql, con, 1    ' 1 = adOpenKeyset
   
    ' If no item matches, report the error and exit the function.
    If (rs.EOF) Then
        MsgBox "There was an error reading the " & _
            "Switchboard Items table."
        rs.Close
        Set rs = Nothing
        Set con = Nothing
        Exit Function
    End If

'Compare the Command value with the declared constant
'and carry out the matching command. 
Select Case rs![Command]
       
  'Go to another switchboard.
Case conCmdGotoSwitchboard
   Me.Filter = "[ItemNumber] = 0 AND [SwitchboardID]=" &_ 
        rs![Argument]
          
' Open a form in Add mode.
Case conCmdOpenFormAdd
   DoCmd.OpenForm rs![Argument], , , , acAdd

' Open a form.
Case conCmdOpenFormBrowse
   DoCmd.OpenForm rs![Argument]

' Open a report.
Case conCmdOpenReport
   DoCmd.OpenReport rs![Argument], acPreview

' Customize the Switchboard.
Case conCmdCustomizeSwitchboard
   ' Handle the case where the Switchboard Manager
   ' is not installed (e.g. Minimal Install).
   On Error Resume Next
   Application.Run "ACWZMAIN.sbm_Entry"
   If (Err <> 0) Then MsgBox "Command not available."
   On Error GoTo 0
   ' Update the form.
   Me.Filter = "[ItemNumber] = 0 AND [Argument] = 'Default' "
   Me.Caption = Nz(Me![ItemText], "")
   FillOptions

' Exit the application.
Case conCmdExitApplication
   CloseCurrentDatabase

' Run a macro.
Case conCmdRunMacro
   DoCmd.RunMacro rs![Argument]

' Run code.
Case conCmdRunCode
   Application.Run rs![Argument]

' Open a Data Access Page
Case conCmdOpenPage
   DoCmd.OpenDataAccessPage rs![Argument]

' Any other command is unrecognized.
Case Else
   MsgBox "Unknown option."
   
   End Select
  ' Close the recordset and the database.
    rs.Close
   
HandleButtonClick_Exit:
On Error Resume Next
    Set rs = Nothing
    Set con = Nothing
    Exit Function

HandleButtonClick_Err:
    ' If the action was cancelled by the user for
    ' some reason, don't display an error message.
    ' Instead, resume on the next line.
    If (Err = conErrDoCmdCancelled) Then
        Resume Next
    Else
        MsgBox "There was an error executing the command.", & _    
        vbCritical
       Resume HandleButtonClick_Exit
    End If
   
End Function
Code example 11-3
Public Function GetSupervisor(EmpCN As Long) As String
'This function uses the Employee Company Number to find and return
'the full name of the employee's supervisor.

On Error GoTo GetSupervisor_Err

Dim rst As Recordset
Dim strSQL As String

strSQL = "SELECT * FROM tblEmployee WHERE tblEmployee.EmpCN = "

'The next statement concatenates the EmpCN argument value
'with the SQL string and opens the recordset with that criterion.
'Then GetSupervisor is set to the value of the Supervisor
'field in the resulting record.

Set rst = CurrentDb.OpenRecordset(strSQL & EmpCN) 
GetSupervisor = rst!Supervisor

GetSupervisor_Exit:
    Exit function

GetSupervisor_Err:
    If Err.Number <> 0 then
  MsgBox Err.Number & " " & Error.Description
    End If
End Function
Code example 11-4
Public Function GetEmpStatus(EmpStatus As Long) As String
On Error GoTo GetEmpStatus_Err

Dim rst As Recordset
Dim strSQL As String

    strSQL = "SELECT * FROM EmpStatus WHERE EmpStatus.StatusID = "
    Set rst = CurrentDb.OpenRecordset(strSQL & EmpStatus)
   
    GetEmpStatus = EmpStatus!Status

GetEmpStatus_Exit:
   Exit Function
  
GetEmpStatus_Err:
   If Err.No <> 0 then
         MsgBox = Err.Number & " " & Err.Description
   End If
End Function
Code example 11-5
Public Function GetSupervisorExt(strEmployee As String) As String
'This is a simple example of a function that sends
'the employee's name as the argument, and returns
'the employee's supervisor name and contact extension.
On Error GoTo GetSupervisorExt_Err

Dim strSupName As String
Dim strPhoneNo As String

strSupName = DLookup("Supervisor", "tblEmployees", _
                    "EmployeeName ='" & strEmployee & "'")
strPhoneExt = DLookup("WorkPhone", "tblPhoneList", _
                    "EmployeeName ='" & strSupName & "'")
GetSupervisorExt = "This employees supervisor is " & strSupName _
& " and can be reached at extension:" & _ strPhoneExt
GetSupervisorExt_Exit:
    Exit Function
GetSupervisorExt_Err:
   If Err.No <> 0 then
       MsgBox = Err.Number & " " & Err.Description
   End If
End Function
Code example 11-6
Public Function GetFullName(FirstName As String, MI As String, _     LastName As String) As String
'This function concatenates the first name with the middle initial 'and last name.
'If there is no middle initial, the first and last names close up.

GetFullName = FirstName & " " & IIf(IsNull([MI]), "", [MI]) & _
    " " & LastName
End Function
Code example 11-7
Public Function IsLoaded(ByVal strFormName As String) As Integer
'This function returns True If the named form is open in Form View
'or Datasheet View. False if not.

Const conObjStateClosed = 0
Const conDesignView = 0

If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> _
    conObjStateClosed Then
    If Forms(strFormName).CurrentView <> conDesignView Then
        IsLoaded = True
    End If
End If
End Function
Code example 11-8
Private Sub Field7_GotFocus()
On Error GoTo Field7_Err:
    'Declare all the objects and variables used in the procedure.
    Dim tdf As DAO.TableDef
    Dim dbs As DAO.Database
    Dim fld As DAO.Field
    Dim ctlName As Control
    Dim srcType As Integer
    Dim srcTypeName As String
   
    Set db = CurrentDb
    Set tdf = db.TableDefs(Me.RecordSource)
    Set ctlName = Me.ActiveControl
    Debug.Print Me.ActiveControl

    'Step through the list of fields in the table to find the
    'control source for the field in question.
    'Set the srcType variable to the integer value of the data type.

    For Each fld In tdf.Fields     
        If fld.Name = ctlName.ControlSource Then
            srcType = fld.Properties("Type")
        End If
    Next fld
    Debug.Print srcType
    'Call the FieldType function and pass the srcType argument.
    srcTypeName = FieldType(srcType)
    MsgBox ctlName.ControlSource & " is " & srcTypeName & _
" data type."
Field7_Exit:
    Exit Sub
   
Field7_Err:
    If Err.Number <> 0 Then
        MsgBox Err.Number & " " & Err.Description
    End If
End Sub
Code example 11-9
Function FieldType(fldType As Integer) As String
'Uses the passed integer field type to find the text definition.
On Error GoTo FieldType_Err:

   Select Case fldType
       Case 1
           FieldType = "Boolean"
       Case 2
           FieldType = "Byte"
       Case 3
           FieldType = "Integer"
       Case 4
           FieldType = "Long"
       Case 5
           FieldType = "Currency"
       Case 6
           FieldType = "Single"
       Case 7
           FieldType = "Double"
       Case 8
           FieldType = "Date"
       Case 10
           FieldType = "Text"
       Case 11
           FieldType = "OLE"
       Case 12
           FieldType = "Memo"
       Case 15
           FieldType = "GUID (Replication-ID)"
   End Select
   Debug.Print FieldType

FieldType_Exit:
   Exit Function

FieldType_Err:
   If Err.No <> 0 then
         MsgBox = Err.Number & " " & Err.Description
   End If
End Function


Access Power Programming with VBA, 8/23/2003, Web code examples
Virginia Andersen


